Celestin Apprentice 7

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Mines / Mines.icl next >

Wrap

Text File | 1997-04-25 | 16.5 KB | 499 lines | [TEXT/3PRM]

module Mines /* The game 'MacMines' in Concurrent Clean. This program requires the 0.8 I/O library. Run the program using the "No Console" option (Application options). */ import StdInt, StdMisc, StdBool, StdString, StdArray, StdList, StdTuple import deltaEventIO, deltaMenu, deltaTimer, deltaDialog, deltaSystem import MinesBest, Help :: *Mines = { minefield :: Minefield , nr_visible :: NrVisible , pebbles :: Pebbles , nr_mines :: NrMines , dimension :: Dimension , time :: Time , best :: MinesBest , font :: Font , seed :: RandomSeed } :: NrMines :== Int :: NrVisible :== Int :: *IO :== IOState Mines MinesID :== 1 NewGameID :== 10 HelpID :== 11 BestTimesID :== 12 QuitID :== 13 SkillID :== 2 EasyID :== 20 InterID :== 21 HardID :== 22 CustomID :== 23 SkillDialogID :== 1 WidthID :== 11 HeightID :== 12 NrMinesID :== 13 OkID :== 14 CancelID :== 15 OverDlogID :== 2 NameID :== 21 OverOKID :== 22 TimerID :== 1 WindowID :== 1 BestWdID :== 2 HelpFile :== "MinesHelp" HiScoresFile :== "mineshi" Start :: *World -> *World Start world # (files, world) = openfiles world (events,world) = OpenEvents world (aboutdialog,files) = MakeAboutDialog "Mines" HelpFile files Help (hifile,best) = ReadHiScores HiScoresFile files state0 = InitialMines EasyMines EasyDim best (stateN,events) = StartIO [menu,window,time,DialogSystem [aboutdialog]] state0 [InitialiseRandomSeed] events files = WriteHiScores hifile stateN.best world = closefiles files world world = CloseEvents events world = world where menu = MenuSystem [ PullDownMenu MinesID "Mines" Able [ MenuItem NewGameID "New Game" (Key 'N') Able NewGame , MenuItem BestTimesID "Best Times" (Key 'B') Able ShowBest , MenuSeparator , MenuItem QuitID "Quit" (Key 'Q') Able Quit ] , PullDownMenu SkillID "Skill" Able [ MenuRadioItems EasyID [ MenuRadioItem EasyID "Easy" (Key 'E') Able (SetGame EasyMines EasyDim) , MenuRadioItem InterID "Intermediate" (Key 'I') Able (SetGame InterMines InterDim) , MenuRadioItem HardID "Hard" (Key 'H') Able (SetGame HardMines HardDim) , MenuRadioItem CustomID "Custom..." (Key 'C') Able Custom ] ] ] window = WindowSystem [ FixedWindow WindowID (0,0) "Mines" (WindowPictDomain EasyDim) DrawGame [ GoAway Quit , Mouse Able PlayMines ] ] time = TimerSystem [ Timer TimerID Unable TicksPerSecond Timing ] InitialMines :: Int Dimension MinesBest -> Mines InitialMines nrmines dim best = { minefield = [[]] , nr_visible = 0 , pebbles = [] , nr_mines = nrmines , dimension = dim , time = Off , best = best , font = snd (SelectFont "Times" ["BoldStyle"] 12) , seed = NullRandomSeed } InitialiseRandomSeed :: Mines IO -> (Mines, IO) InitialiseRandomSeed mines=:{nr_mines,dimension} io # (seed,io) = GetNewRandomSeed io (field,seed) = SowMines nr_mines dimension seed = ({mines & minefield=field,seed=seed},io) SetMines :: Int Dimension Mines -> Mines SetMines nrmines dim mines=:{seed} # (field,seed) = SowMines nrmines dim seed = { mines & minefield = field , nr_visible = 0 , pebbles = [] , nr_mines = nrmines , dimension = dim , time = Off , seed = seed } Help :: Mines IO -> (Mines, IO) Help mines=:{best=(files,bt)} io # (files,io) = ShowHelp HelpFile files io = ({mines & best=(files,bt)},io) Custom :: Mines IO -> (Mines, IO) Custom mines=:{pebbles,nr_mines,dimension=(col,row)} io = OpenModalDialog dialog mines io where dialog = CommandDialog SkillDialogID "Custom" [] OkID [ StaticText 1 Left widthtext , EditText WidthID (RightTo 1) (Pixel 40) 1 (toString col) , StaticText 3 Left heighttext , EditText HeightID (Below WidthID) (Pixel 40) 1 (toString row) , StaticText 5 Left "Mines:" , EditText NrMinesID (Below HeightID) (Pixel 40) 1 (toString total) , DialogButton CancelID Center "Cancel" Able Cancel , DialogButton OkID (RightTo CancelID) "OK" Able OK ] total = length pebbles + nr_mines widthtext = "Width ("+++toString minw+++"-"+++toString maxw+++"):" heighttext = "Height ("+++toString minh+++"-"+++toString maxh+++"):" (minw,minh) = (1,2) (maxw,maxh) = MaxDimension Cancel :: DialogInfo Mines IO -> (Mines, IO) Cancel _ mines io = (mines, CloseActiveDialog io) OK :: DialogInfo Mines IO -> (Mines, IO) OK info mines io = SetGame nr dim mines1 (CloseActiveDialog io) where width = Between minw maxw (toInt (GetEditText WidthID info)) height = Between minh maxh (toInt (GetEditText HeightID info)) nr = Between 1 (width*height) (toInt (GetEditText NrMinesID info)) dim = (width,height) mines1 = {mines & minefield=[],nr_visible=0,pebbles=[],nr_mines=nr,dimension=dim} Between :: !Int !Int !Int -> Int Between min max n | n<min = min | n>max = max | otherwise = n /* The menu definition: */ Quit :: Mines IO -> (Mines, IO) Quit mines io = (mines, QuitIO io) NewGame :: Mines IO -> (Mines, IO) NewGame mines=:{pebbles,nr_mines,dimension} io # io = ChangeUpdateFunction WindowID DrawGame io io = ActivateWindow WindowID io io = EnableMouse WindowID io mines = SetMines (length pebbles+nr_mines) dimension mines (mines,io) = DrawInWindowFrame WindowID EraseBeforeDraw mines io = (mines,io) ShowBest :: Mines IO -> (Mines, IO) ShowBest mines io = (mines, OpenWindows [FixedWindow BestWdID (40,40) "Hall of Fame" ((0,0),size) UpdateBest []] io) where size = (BestX,BestY) UpdateBest :: UpdateArea Mines -> (Mines, [DrawFunction]) UpdateBest area mines=:{best=(_,hi)} = (mines,ShowBestTimes hi) SetGame :: Int Dimension Mines IO -> (Mines, IO) SetGame nr dim mines io # io = ChangeUpdateFunction WindowID DrawGame io mines = SetMines nr dim mines (mines,io) = ChangePictureDomain WindowID (WindowPictDomain dim) mines io io = EnableMouse WindowID io io = ActivateWindow WindowID io = (mines,io) /* The mouse definition: */ PlayMines :: MouseState Mines IO -> (Mines, IO) PlayMines (_,ButtonUp,_) mines io = (mines, io) PlayMines (_,ButtonStillDown,_) mines io = (mines, io) PlayMines (pos,_,mods=:(shift,_,_,_)) mines=:{dimension} io | shift = PutOrGetPebble (MousePositionToPosition pos dimension) mines io | NoMods mods = StepCautiously (MousePositionToPosition pos dimension) mines io | otherwise = (mines,io) where NoMods (False,False,False,False) = True NoMods _ = False MousePositionToPosition :: Point Dimension -> Position MousePositionToPosition (x,y) (col,row) | x<size*col && y<size*row = (x/size+1,y/size+1) | otherwise = (0,0) where size = SizeArea PutOrGetPebble :: Position Mines IO -> (Mines, IO) PutOrGetPebble (0,0) mines io = (mines, io) PutOrGetPebble pos mines=:{pebbles,nr_mines=0} io | isMember pos pebbles = GetPebble pos mines io | otherwise = (mines, io) PutOrGetPebble pos mines=:{pebbles,time=Running _} io | isMember pos pebbles = GetPebble pos mines io | otherwise = PutPebble pos mines io PutOrGetPebble pos mines=:{time=Off} io = PutPebble pos {mines & time=Running 0} (EnableTimer TimerID io) PutPebble :: Position Mines IO -> (Mines, IO) PutPebble pos mines=:{minefield,nr_visible,pebbles,nr_mines} io | not (InvisibleSpot (GetSpot pos minefield)) = (mines, io) | otherwise = FinalSpotRevealed mines1 io1 with mines1 = {mines & nr_visible=nr_visible+1,pebbles=[pos:pebbles],nr_mines=nr_mines-1} io1 = DrawInWindow WindowID [DrawPebble pos] io GetPebble :: Position Mines IO -> (Mines, IO) GetPebble pos mines=:{nr_visible,pebbles,nr_mines,dimension,font} io # io = DrawInWindow WindowID [DrawEmptyArea pos,DrawNrMines font (nr_mines+1) dimension] io = ({mines & nr_visible=nr_visible-1,pebbles=RemovePebble pos pebbles,nr_mines=nr_mines+1}, io) StepCautiously :: Position Mines IO -> (Mines, IO) StepCautiously (0,0) mines io = (mines, io) StepCautiously pos mines=:{minefield,nr_visible,pebbles,nr_mines,dimension,time=Running _} io | MineSpot spot = (mines1, io2) with io1 = ChangeIOState [ ChangeUpdateFunction WindowID DrawFinalGame , DisableTimer TimerID , DisableMouse WindowID ] io (mines1,io2)= DrawInWindowFrame WindowID DrawFinalGame mines io1 | not (InvisibleSpot spot) = (mines, io) | NulSpot spot = FinalSpotRevealed safe_mines rev_io with (less_pebbles,safe_minefield,nr_revealed_spots,drawfs) = RevealSafeSpots dimension pos pebbles minefield nr_less_pebbles = length less_pebbles more_visible = nr_visible+nr_revealed_spots-(nr_pebbles-nr_less_pebbles) more_mines = nr_pebbles+nr_mines-nr_less_pebbles safe_mines = {mines & minefield = safe_minefield , nr_visible = more_visible , pebbles = less_pebbles , nr_mines = more_mines } rev_io = DrawInWindow WindowID drawfs io | otherwise = FinalSpotRevealed spot_mines spot_io with (spot`,spot_minefield) = RevealSpot pos minefield nr_pebbles_less = length one_pebble_less one_more_mine = nr_mines+nr_pebbles-nr_pebbles_less one_pebble_less = RemovePebble pos pebbles one_more_visible= nr_visible+1+nr_pebbles_less-nr_pebbles spot_mines = {mines & minefield = spot_minefield , nr_visible = one_more_visible , pebbles = one_pebble_less , nr_mines = one_more_mine } spot_io = DrawInWindow WindowID [DrawSpot pos spot`] io where spot = GetSpot pos minefield nr_pebbles = length pebbles StepCautiously pos mines=:{time=Off} io = StepCautiously pos {mines & time=Running 0} (EnableTimer TimerID io) FinalSpotRevealed :: Mines IO -> (Mines, IO) FinalSpotRevealed mines=:{nr_visible,nr_mines,dimension,font} io | nr_mines==0 && nr_visible==fst dimension*snd dimension = CheckForBestTime mines1 io2 with io1 = ChangeIOState [ ChangeUpdateFunction WindowID DrawFinalGame , DisableTimer TimerID , DisableMouse WindowID ] io (mines1,io2)= DrawInWindowFrame WindowID DrawFinalGame mines io1 CheckForBestTime :: Mines IO -> (Mines, IO) CheckForBestTime mines=:{pebbles,dimension,time,best=(_,hi)} io | not (ItsABestTime (length pebbles) dimension time hi) = (mines,io) | otherwise = OpenModalDialog dialog mines io with dialog = CommandDialog OverDlogID "Game Over" [] OverOKID [ StaticText 1 Left "Game Over with a new best time!" , StaticText 2 Left "Your name:" , EditText NameID (RightTo 2) (MM 40.0) 1 "" , DialogButton OverOKID Center "OK" Able Ok ] Ok :: DialogInfo Mines IO -> (Mines, IO) Ok info mines=:{pebbles,dimension,time,best=(files,hi)} io # io = CloseActiveDialog io | name=="" = (mines, io) # io = DrawInWindow BestWdID (ShowBestTimes newhi) io | otherwise = ({mines & best=(files,newhi)}, io) where newhi = AddBestTime (LimitString 16 name) (length pebbles) dimension time hi name = GetEditText NameID info | otherwise = (mines,DrawInWindow WindowID [DrawNrMines font nr_mines dimension] io) DrawFinalGame :: UpdateArea Mines -> (Mines, [DrawFunction]) DrawFinalGame upd_area mines=:{minefield,pebbles,nr_mines,dimension,time,font} = ( mines , [ SetFont font , DrawGrid dimension , DrawNrMines font nr_mines dimension , DrawTime font (GetTime time) dimension : MapMinefield DrawAnySpot minefield ++ MapMinefield (DrawCorrectnessPebble pebbles) minefield ] ) /* The update definition: */ DrawGame :: UpdateArea Mines -> (Mines, [DrawFunction]) DrawGame upd_area mines=:{minefield,pebbles,nr_mines,dimension,time,font,seed} = ( mines , [ SetFont font , DrawGrid dimension , DrawNrMines font nr_mines dimension , DrawTime font (GetTime time) dimension : MapMinefield DrawSpot minefield ++ map DrawPebble pebbles ] ) EraseBeforeDraw :: UpdateArea Mines -> (Mines, [DrawFunction]) EraseBeforeDraw updarea mines # (mines,drawfs) = DrawGame updarea mines = (mines,map EraseRectangle updarea ++ drawfs) /* The timer definition: */ Timing :: TimerState Mines IO -> (Mines, IO) Timing passed mines=:{dimension,time=Running last,font} io = ({mines & time=Running now}, DrawInWindow WindowID [DrawTime font now dimension] io) where now = last+passed Timing _ mines io = (mines, io) // Reveal all newly discovered spots: RevealSafeSpots :: !Dimension !Position Pebbles Minefield -> (Pebbles,Minefield,Int,![DrawFunction]) RevealSafeSpots dim pos pebbles minefield # (spot,minefield) = RevealSpot pos minefield (pebbles,minefield,revealed_spots,drawfs) = RevealAreas dim pos Compass (RemovePebble pos pebbles) minefield [[(pos,spot)]] = (pebbles,minefield,AreaLength revealed_spots,[DrawSpot pos spot:drawfs]) where RevealAreas :: !Dimension !Position ![Vector] Pebbles Minefield [[(Position,Spot)]] -> (Pebbles,Minefield,[[(Position,Spot)]],![DrawFunction]) RevealAreas dim pos [v:vs] pebbles minefield done = (pebbles2,minefield2,done2,drawfs1++drawfs2) where (pebbles1,minefield1,done1,drawfs1) = RevealArea dim (TranslatePoint v pos) v pebbles minefield done (pebbles2,minefield2,done2,drawfs2) = RevealAreas dim pos vs pebbles1 minefield1 done1 RevealAreas _ _ _ pebbles minefield done = (pebbles,minefield,done,[]) RevealArea :: !Dimension !Position Vector Pebbles Minefield [[(Position,Spot)]] -> (Pebbles,Minefield,[[(Position,Spot)]],![DrawFunction]) RevealArea dim pos v pebbles minefield done | not (InMinefield dim pos) || not (UniqueArea pos done) || not (InvisibleSpot spot`) = (pebbles,minefield,done,[]) | NulSpot spot = (pebbles``,minefield``,done``,[DrawSpot pos spot:drawfs``]) with (pebbles``,minefield``,done``,drawfs``) = RevealAreas dim pos vs pebbles` minefield` done` | otherwise = (pebbles`,minefield`,done`,[DrawSpot pos spot]) where (spot,minefield`) = RevealSpot pos minefield done` = AddArea pos spot done pebbles` = RemovePebble pos pebbles vs = NextCompass v spot` = GetSpot pos minefield InMinefield :: !Dimension !Position -> Bool InMinefield (col,row) (x,y) | x==0 || y==0 = False | otherwise = x<=col && y<=row NextCompass :: !Vector -> [Vector] NextCompass v=:(x,y) | x==0 = [v,(y,0),(~y,0),(1,y),(-1,y)] | y==0 = [v,(0,x),(0,~x),(x,1),(x,-1)] | otherwise = [v,(x,0),(0,y),(x,~y),(~x,y)] UniqueArea :: !Position ![[(Position,Spot)]] -> Bool UniqueArea mine=:(x,_) [col_areas=:[area=:((x`,_),_):_]:areas] | x<x` = True | x==x` = UniqueColArea mine col_areas with UniqueColArea :: !Position ![(Position,Spot)] -> Bool UniqueColArea mine=:(_,y) [((_,y`),_):areas] | y<y` = True | y==y` = False | otherwise = UniqueColArea mine areas UniqueColArea _ _ = True | otherwise = UniqueArea mine areas UniqueArea mine [[] : areas] = UniqueArea mine areas UniqueArea _ _ = True AddArea :: !Position Spot ![[(Position,Spot)]] -> [[(Position,Spot)]] AddArea pos=:(x,_) spot [col_areas=:[area=:((x`,_),_):_]:areas] | x<x` = [[(pos,spot)], col_areas : areas] | x==x` = [AddColArea pos spot col_areas : areas] with AddColArea :: Position Spot [(Position, Spot)] -> [(Position, Spot)] AddColArea pos=:(_,y) spot [area=:((_,y`),_):areas] | y<y` = [(pos,spot),area:areas] | y==y` = [area:areas] | otherwise = [area:AddColArea pos spot areas] AddColArea pos spot _ = [(pos,spot)] | otherwise = [col_areas:AddArea pos spot areas] AddArea pos spot [[]:areas] = AddArea pos spot areas AddArea pos spot [] = [[(pos,spot)]] AreaLength :: ![[x]] -> Int AreaLength [list:lists] = length list+AreaLength lists AreaLength _ = 0 Compass :== [(-1,-1), (0,-1), (1,-1), (1,0), (1,1), (0,1), (-1,1), (-1,0)] // Map a Spot at Position drawing function over the minefield: :: DrawSpotFunction :== Position -> Spot -> DrawFunction MapMinefield :: !DrawSpotFunction !Minefield -> [DrawFunction] MapMinefield f minefield = flatten (snd (smap (MapColMinefield f) 1 minefield)) where MapColMinefield :: !DrawSpotFunction !Int ![Spot] -> (!Int,![DrawFunction]) MapColMinefield f col col_mines = (col+1,snd (smap (MapCol f) (col,1) col_mines)) where MapCol :: !DrawSpotFunction !Position !Spot -> (!Position,!DrawFunction) MapCol f pos=:(col,row) spot = ((col,row+1),f pos spot) smap :: !(!.s -> .x -> (!.s,.y)) !.s ![.x] -> (!.s,![.y]) smap f s [x:xs] # (s,y) = f s x (s,ys) = smap f s xs = (s,[y:ys]) smap _ s _ = (s,[])